home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN2.LZH / TOSTD.FOR < prev    next >
Encoding:
Text File  |  1988-02-08  |  4.3 KB  |  151 lines
  1.       SUBROUTINE TOSTD ( VALIN, STRIN, VALOUT, STROUT, IERR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          TOSTD            **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          TO STANDARD UNITS
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD,  CA     94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          CONVERTS A VALUE WITH NON-STANDARD UNITS TO THE EQUIVALENT
  23. C*          VALUE WITH STANDARD UNITS AND RETURNS THE STANDARD UNITS.
  24. C*
  25. C*     METHODOLOGY :
  26. C*          PARSES THE INPUT UNITS, REPLACES EACH ONE WITH AN EQUIVALENT
  27. C*          STANDARD UNIT AND A SCALE FACTOR, MULTIPLIES THE SCALE FACTORS
  28. C*          TOGETHER AND EVALUATES THE UNITS STRING.
  29. C*
  30. C*     INPUT ARGUMENTS :
  31. C*          VALIN  - THE VALUE OF THE VARIABLE WITH THE ORIGINAL UNITS
  32. C*          STRIN  - THE STRING CONTAINING THE UNITS OF THE INPUT VALUE
  33. C*
  34. C*     OUTPUT ARGUMENTS :
  35. C*          VALOUT - THE VALUE AFTER CONVERSION TO STANDARD UNITS
  36. C*          STROUT - THE STRING CONTAINING THE STANDARD UNITS
  37. C*          IERR   - 0 = NO ERROR
  38. C*                   1 = ILLEGAL CHARACTERS IN UNITS OR BAD EXPONENT
  39. C*                   2 = UNKNOWN UNIT IN INPUT STRING
  40. C*                   3 = TOO COMPLICATED TO EVALUATE OR UNMATCHED PARENS
  41. C*
  42. C*     INTERNAL WORK AREAS :
  43. C*          WORK - TEMPORARY STRING FOR REPLACEMENT OF NON-STD SYMBOLS
  44. C*          TOP, BOTTOM - ARRAYS TO HOLD THE UNITS EXTRACTED FROM STRIN
  45. C*
  46. C*     COMMON BLOCKS :
  47. C*          NONE
  48. C*
  49. C*     FILE REFERENCES :
  50. C*          NONE
  51. C*
  52. C*     SUBPROGRAM REFERENCES :
  53. C*          LENGTH,   PARSE,   STD,   POLISH,   EVAL,   BUILD,  CAPS
  54. C*
  55. C*     ERROR PROCESSING :
  56. C*          ERRORS PASSED FROM SUBROUTINES
  57. C*
  58. C*     TRANSPORTABILITY LIMITATIONS :
  59. C*          NONE
  60. C*
  61. C*     ASSUMPTIONS AND RESTRICTIONS :
  62. C*          THE INPUT UNITS STRING AND THE RESULTING OUTPUT STRING MUST BE
  63. C*           SHORTER THAN 255 CHARACTERS.
  64. C*
  65. C*     LANGUAGE AND COMPILER :
  66. C*          ANSI FORTRAN 77
  67. C*
  68. C*     VERSION AND DATE :
  69. C*          VERSION I.1      13-SEP-85
  70. C*
  71. C*     CHANGE HISTORY :
  72. C*          13-SEP-85    EFFICIENCY IMPROVED, BETTER UNITS CONVERSIONS
  73. C*           7-FEB-85    INITIAL VERSION
  74. C*
  75. C***********************************************************************
  76. C*
  77.       PARAMETER (WLEN=255)
  78.       CHARACTER *(*) STRIN, STROUT
  79.       CHARACTER *(WLEN) WORK
  80.       CHARACTER *6 TOP(40), BOTTOM(40), TOKE(100)
  81.       DOUBLE PRECISION FACTOR, FACTS(100)
  82.       LOGICAL ERROR
  83. C
  84.       WORK   = STRIN
  85.       CALL CAPS ( WORK )
  86.       ERROR  = .FALSE.
  87.       IERR   = 0
  88.       FAC    = 1.0D0
  89.       L      = LENGTH ( WORK )
  90. C
  91. C --- PASS 1, REPLACE '-' WITH '*'   AND   '**' WITH '^'
  92. C
  93.       J = 0
  94.       I = 1
  95. 5     IF (WORK(I:I) .EQ. '-') THEN
  96.          J = J + 1
  97.          WORK(J:J) = '*'
  98.       ELSE IF (WORK(I:I+1) .EQ. '**') THEN
  99.          J = J + 1
  100.          I = I + 1
  101.          WORK(J:J) = '^'
  102. C
  103. C --- ALL OTHER CHARACTERS EXCEPT ' ' GET COPIED
  104. C
  105.       ELSE IF (WORK(I:I) .NE. ' ') THEN
  106.          J = J + 1
  107.          WORK(J:J) = WORK(I:I)
  108.       ENDIF
  109.       I = I + 1
  110.       IF ( I .LE. L )GO TO 5
  111.       WORK(J+1:) = ' '
  112. C
  113. C --- PASS 2, PARSE INTO TOKENS
  114. C
  115.       CALL PARSE ( WORK, J, TOKE, NTOKE, ERROR )
  116.       IF ( ERROR ) THEN
  117.          IERR = 1
  118.          RETURN
  119.       ENDIF
  120. C
  121. C --- PASS 3, REPLACE NON-STANDARD UNITS WITH STANDARD
  122. C
  123.       CALL STD ( FACTS, TOKE, NTOKE, ERROR )
  124.       IF ( ERROR ) THEN
  125.          IERR = 2
  126.          RETURN
  127.       ENDIF
  128. C
  129. C --- PASS 4, CONVERT TO REVERSE POLISH
  130. C
  131.       CALL POLISH ( TOKE, NTOKE, FACTS, ERROR )
  132.       IF ( ERROR ) THEN
  133.          IERR = 3
  134.          RETURN
  135.       ENDIF
  136. C
  137. C --- PASS 5, EVALUATE CONVERSION FACTORS
  138. C
  139.       CALL EVAL ( TOKE, NTOKE, FACTS, TOP, NTOP, BOTTOM, NBOT, FACTOR )
  140. C
  141.       VALOUT = VALIN * SNGL (FACTOR)
  142. C
  143. C --- PASS 6, BUILD OUTPUT UNIT STRING
  144. C
  145.       CALL BUILD ( STROUT, TOP, NTOP, BOTTOM, NBOT )
  146.       RETURN
  147.       END
  148. C
  149. C---END TOSTD
  150. C
  151.